home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Grab Bag
/
Shareware Grab Bag.iso
/
050
/
madtrb31.arc
/
PIBMUSIC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-06-04
|
25KB
|
564 lines
(*$R-,V-,C-,U-*)
Program PibMusic;
(* ------------------------------------------------------------------------ *)
(* *)
(* Program: PibMusic *)
(* *)
(* Purpose: Demonstrates the enclosed routine PibPlay, which emulates *)
(* the Microsoft Basic PLAY statement. (See the Basic manual *)
(* for details.) *)
(* *)
(* Author: Philip R. Burns *)
(* Date: January 25, 1985 *)
(* Version: 1.0 *)
(* *)
(* Use: *)
(* *)
(* Call PibPlaySet to initialize global play variables. *)
(* Call PibPlay to play a line of music. *)
(* *)
(* Remarks: You are free to use this routine is your own code. If you *)
(* find any bugs or have suggestions for improvements, please *)
(* leave them for me on one of the following two Chicago BBSs: *)
(* *)
(* Gene Plantz's IBBS (312) 882 4227 *)
(* Ron Fox's RBBS (312) 940 6496 *)
(* *)
(* Thanks. *)
(* *)
(* Note: This code ignores requests for buffered music. *)
(* *)
(* ------------------------------------------------------------------------ *)
(* Global Variable for PibMusic *)
Var
(* String containing music *)
S : String[255];
(* ------------------------------------------------------------------------ *)
(* PibPlaySet --- Set up to play music *)
(* PibPlay --- Play Music through Speaker *)
(* ------------------------------------------------------------------------ *)
(* Global Type for PibPlay Procedure *)
Type
SoundStr = String[255];
(* Global Variables for PibPlay Procedure *)
Var
(* Current Octave for Note *)
Note_Octave : Integer;
(* Fraction of duration given to note *)
Note_Fraction : Real;
(* Duration of note *)
Note_Duration : Integer;
(* Length of note *)
Note_Length : Real;
(* Length of quarter note (principal beat) *)
Note_Quarter : Real;
Procedure PibPlaySet;
(* ------------------------------------------------------------------------ *)
(* *)
(* Procedure: PibPlaySet *)
(* *)
(* Purpose: Sets up to play music though PC's speaker *)
(* *)
(* Calling Sequence: *)
(* *)
(* PibPlaySet; *)
(* *)
(* Calls: None *)
(* *)
(* ------------------------------------------------------------------------ *)
Begin (* PibPlaySet *)
(* Default Octave *)
Note_Octave := 4;
(* Default sustain is semi-legato *)
Note_Fraction := 0.875;
(* Note is quarter note by default *)
Note_Length := 0.25;
(* Moderato pace by default *)
Note_Quarter := 500.0;
End (* PibPlaySet *);
Procedure PibPlay( S : SoundStr );
(* ------------------------------------------------------------------------ *)
(* *)
(* Procedure: PibPlay *)
(* *)
(* Purpose: Play music though PC's speaker *)
(* *)
(* Calling Sequence: *)
(* *)
(* PibPlay( Music_String : SoundStr ); *)
(* *)
(* Music_String --- The string containing the encoded music to be *)
(* played. The format is the same as that of the *)
(* MicroSoft Basic PLAY Statement. The string *)
(* must be <= 254 characters in length. *)
(* *)
(* Calls: Sound *)
(* GetInt (Internal) *)
(* *)
(* Remarks: The characters accepted by this routine are: *)
(* *)
(* A - G Musical Notes *)
(* # or + Following A - G note, indicates sharp *)
(* - Following A - G note, indicates flat *)
(* < Move down one octave *)
(* > Move up one octave *)
(* . Dot previous note (extend note duration by 3/2) *)
(* MN Normal duration (7/8 of interval between notes) *)
(* MS Staccato duration *)
(* ML Legato duration *)
(* Ln Length of note (n=1-64; 1=whole note, *)
(* 4=quarter note, etc.) *)
(* Pn Pause length (same n values as Ln above) *)
(* Tn Tempo, n=notes/minute (n=32-255, default n=120) *)
(* On Octave number (n=0-6, default n=4) *)
(* Nn Play note number n (n=0-84) *)
(* *)
(* The following two commands are IGNORED by PibPlay: *)
(* *)
(* MF Complete note before continuing *)
(* MB Another process may begin before speaker is *)
(* finished playing note *)
(* *)
(* IMPORTANT --- PibPlaySet MUST have been called at least once before *)
(* this routine is called. *)
(* *)
(* ------------------------------------------------------------------------ *)
Const
(* Offsets in octave of natural notes *)
Note_Offset : Array[ 'A'..'G' ] Of Integer
= ( 9, 11, 0, 2, 4, 5, 7 );
(* Frequencies for 7 octaves *)
Note_Freqs: Array[ 0 .. 84 ] Of Integer
=
(*
C C# D D# E F F# G G# A A# B
*)
( 0,
65, 69, 73, 78, 82, 87, 92, 98, 104, 110, 116, 123,
131, 139, 147, 156, 165, 175, 185, 196, 208, 220, 233, 247,
262, 278, 294, 312, 330, 350, 370, 392, 416, 440, 466, 494,
524, 556, 588, 624, 660, 700, 740, 784, 832, 880, 932, 988,
1048, 1112, 1176, 1248, 1320, 1400, 1480, 1568, 1664, 1760, 1864, 1976,
2096, 2224, 2352, 2496, 2640, 2800, 2960, 3136, 3328, 3520, 3728, 3952,
4192, 4448, 4704, 4992, 5280, 5600, 5920, 6272, 6656, 7040, 7456, 7904 );
Quarter_Note = 0.25; (* Length of a quarter note *)
Var
(* Frequency of note to be played *)
Play_Freq : Integer;
(* Duration to sound note *)
Play_Duration : Integer;
(* Duration of rest after a note *)
Rest_Duration : Integer;
(* Offset in Music string *)
I : Integer;
(* Current character in music string *)
C : Char;
(* Note Frequencies *)
Freq : Array[ 0 .. 6 , 0 .. 11 ] Of Integer ABSOLUTE Note_Freqs;
N : Integer;
XN : Real;
K : Integer;
Function GetInt : Integer;
(* --- Get integer from music string --- *)
Var
N : Integer;
Begin (* GetInt *)
N := 0;
While( S[I] In ['0'..'9'] ) Do
Begin
N := N * 10 + ORD( S[I] ) - ORD('0');
I := I + 1;
End;
I := I - 1;
GetInt := N;
End (* GetInt *);
Begin (* PibPlay *)
(* Append blank to end of music string *)
S := S + ' ';
(* Point to first character in music *)
I := 1;
(* Begin loop over music string *)
While( I < LENGTH( S ) ) Do
Begin (* Interpret Music *)
(* Get next character in music string *)
C := Upcase(S[I]);
(* Interpret it *)
Case C Of
'A'..'G' : Begin (* A Note *)
N := Note_Offset[ C ];
Play_Freq := Freq[ Note_Octave , N ];
XN := Note_Quarter * ( Note_Length / Quarter_Note );
Play_Duration := Trunc( XN * Note_Fraction );
Rest_Duration := Trunc( XN * ( 1.0 - Note_Fraction ) );
(* Check for sharp/flat *)
If S[I+1] In ['#','+','-' ] Then
Begin
I := I + 1;
Case S[I] OF
'#' : Play_Freq :=
Freq[ Note_Octave , N + 1 ];
'+' : Play_Freq :=
Freq[ Note_Octave , N + 1 ];
'-' : Play_Freq :=
Freq[ Note_Octave , N - 1 ];
Else ;
End (* Case *);
End;
(* Check for note length *)
If S[I+1] In ['0'..'9'] Then
Begin
I := I + 1;
N := GetInt;
XN := ( 1.0 / N ) / Quarter_Note;
Play_Duration :=
Trunc( Note_Fraction * Note_Quarter * XN );
Rest_Duration :=
Trunc( ( 1.0 - Note_Fraction ) *
Xn * Note_Quarter );
End;
(* Check for dotting *)
If S[I+1] = '.' Then
Begin
XN := 1.0;
While( S[I+1] = '.' ) Do
Begin
XN := XN * 1.5;
I := I + 1;
End;
Play_Duration :=
Trunc( Play_Duration * XN );
End;
(* Play the note *)
Sound( Play_Freq );
Delay( Play_Duration );
NoSound;
Delay( Rest_Duration );
End (* A Note *);
'M' : Begin (* 'M' Commands *)
I := I + 1;
C := S[I];
Case C Of
'F' : ;
'B' : ;
'N' : Note_Fraction := 0.875;
'L' : Note_Fraction := 1.000;
'S' : Note_Fraction := 0.750;
Else ;
End (* Case *);
End (* 'M' Commands *);
'O' : Begin (* Set Octave *)
I := I + 1;
N := ORD( S[I] ) - ORD('0');
If ( N < 0 ) OR ( N > 6 ) Then N := 4;
Note_Octave := N;
End (* Set Octave *);
'<' : Begin (* Drop an octave *)
If Note_Octave > 0 Then
Note_Octave := Note_Octave - 1;
End (* Drop an octave *);
'>' : Begin (* Ascend an octave *)
If Note_Octave < 6 Then
Note_Octave := Note_Octave + 1;
End (* Ascend an octave *);
'N' : Begin (* Play Note N *)
I := I + 1;
N := GetInt;
If ( N > 0 ) AND ( N <= 84 ) Then
Begin
Play_Freq := Note_Freqs[ N ];
XN := Note_Quarter *
( Note_Length / Quarter_Note );
Play_Duration := Trunc( XN * Note_Fraction );
Rest_Duration := Trunc( XN * ( 1.0 - Note_Fraction ) );
End
Else If ( N = 0 ) Then
Begin
Play_Freq := 0;
Play_Duration := 0;
Rest_Duration :=
Trunc( Note_Fraction * Note_Quarter *
( Note_Length / Quarter_Note ) );
End;
Sound( Play_Freq );
Delay( Play_Duration );
NoSound;
Delay( Rest_Duration );
End (* Play Note N *);
'L' : Begin (* Set Length of Notes *)
I := I + 1;
N := GetInt;
If N > 0 Then Note_Length := 1.0 / N;
End (* Set Length of Notes *);
'T' : Begin (* # of quarter notes in a minute *)
I := I + 1;
N := GetInt;
Note_Quarter := ( 1092.0 / 18.2 / N ) * 1000.0;
End (* # of quarter notes in a minute *);
'P' : Begin (* Pause *)
I := I + 1;
N := GetInt;
If ( N < 1 ) Then N := 1
Else If ( N > 64 ) Then N := 64;
Play_Freq := 0;
Play_Duration := 0;
Rest_Duration :=
Trunc( ( ( 1.0 / N ) / Quarter_Note )
* Note_Quarter );
Sound( Play_Freq );
Delay( Play_Duration );
NoSound;
Delay( Rest_Duration );
End (* Pause *);
Else
(* Ignore other stuff *);
End (* Case *);
I := I + 1;
End (* Interpret Music *);
(* Make sure sound turned off when through *)
NoSound;
End (* PibPlay *);
Begin (* PibMusic *)
(* Play Happy Birthday as example *)
Writeln(' Playing Happy Birthday ... ');
PibPlaySet;
PibPlay('MBT120L4MFMNO4C8C8DCFE2C8C8DCGF2C8C8O5CO4A F E D2T90 B-8 B-8 A F G F2');
Delay( 1000 );
(* And Broadway *)
Writeln(' Playing Broadway ... ');
PibPlaySet;
PibPlay('MSO3L16EL6EL16EL4EL4EL8EL4DL2FP4P16L16DL6DL16DL4DL4DL4DL2CP4P8P16'+
'EL6EL16EL4EL4EL8EL4DL2FP4P16L16DL6DL16DL4DL4DL4DL2CP4P8P16');
Delay( 1000 );
Writeln(' Playing William Tell Overture ... ');
PibPlaySet;
PibPlay('L16T155');
PibPlay('o2mnb4p8msbbmnb4p8msbbb8g#8');
PibPlay('e8g#8b8g#8b8o3e8o2b8g#8e8g#8');
PibPlay('b8g#8b8o3e8o2mnb4p8msbbmnb4');
PibPlay('p8msbbmnb4p8msbbmnb4p8msbb');
PibPlay('b8bbb8b8b8bbb8b8b8bb');
PibPlay('b8b8b8bbb8b8mlb2');
PibPlay('b2b8p8p4p4');
PibPlay('p8mso1bbb8bbb8bbo2e8f#8g#8o1bb');
PibPlay('b8bbo2e8g#g#f#8d#8o1b8bbb8bb');
PibPlay('b8bbo2e8f#8g#8eg#mlb4bmsag#f#');
PibPlay('e8g#8e8o3bbb8bbb8bbo4e8f#8');
PibPlay('g#8o3bbb8bbo4e8g#g#f#8d#8o3b8bb');
PibPlay('b8bbb8bbo4e8f#8g#8mleg#b4');
PibPlay('bag#f#mse8g#8e8o3g#g#g#8g#g#g#8g#g#');
PibPlay('g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8f#8e8d#8');
PibPlay('c#8g#g#g#8g#g#g#8g#g#g#8o4c#8o3g#8o4c#8');
PibPlay('o3g#8o4c#8o3b8a#8b8a#8b8g#g#g#8g#g#');
PibPlay('g#8g#g#g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8f#8');
PibPlay('e8d#8c#8g#g#g#8g#g#g#8g#g#g#8o4c#8');
PibPlay('o3g#8o4c#8o3g#8o4c#8o3b8a#8b8o2bbb8f#f#');
PibPlay('f#8f#f#f#8g#8a8f#4mna8msg#8mne4');
PibPlay('msg#8f#8f#8f#8o3f#f#f#8f#f#f#8g#8');
PibPlay('a8mnf#4msa8g#8mne4msg#8f#8o2bb');
PibPlay('b8o1bbb8bbb8bbo2mne8f#8g#8o1bb');
PibPlay('b8bbo2e8g#g#f#8d#8o1b8bbb8bb');
PibPlay('b8bbo2e8f#8g#8eg#mlb4mnbag#f#');
PibPlay('e8g#8e8o3bbb8bbb8bbo4e8f#8');
PibPlay('g#8o3bbb8bbo4e8g#g#f#8d#8o3b8bb');
PibPlay('b8bbb8bbo4e8f#8g#8mleg#mlb4');
PibPlay('mnbag#f#mne8g#8e8o3mle56f56g56a56b56o4c56d56mne8eee8e8g#4.');
PibPlay('f#8e8d#8e8c#8mso3bo4c#o3bo4c#o3b');
PibPlay('o4c#d#eo3abababo4c#d#o3g#ag#ag#abo4c#o3f#');
PibPlay('g#f#g#f#g#f#g#f#g#f#d#o2bo3mlbo4c#d#e8d#8e8');
PibPlay('c#8o3msbo4c#o3bo4c#o3bo4c#d#eo3abababo4c#d#o3g#');
PibPlay('ag#ag#abo4c#o3f#g#f#g#f#af#emne8p8mlc#4');
PibPlay('mnc#o2cmso3c#o2co3d#c#o2baag#ec#c#c#c#c#e');
PibPlay('d#o1cg#g#g#g#g#g#o2c#eg#o3c#c#c#c#c#o2co3c#o2co3d#');
PibPlay('c#o2baag#ec#c#c#c#c#ed#o1cg#g#g#g#g#mng#');
PibPlay('o2c#eg#o3msc#ed#c#d#o2cg#g#g#o3g#ec#d#o2cg#g#g#');
PibPlay('o3g#ec#d#o2bg#g#a#gd#d#g#gg#gg#ag#f#e');
PibPlay('o1ba#bo2eo1bo2f#o1bo2g#ed#eg#eaf#bo3g#f#ed#');
PibPlay('f#ec#o2bo3c#o2bo3c#d#ef#g#o2ababo3c#d#ef#o2g#');
PibPlay('ag#aco3c#d#eo2f#g#f#g#f#g#f#g#f#g#f#d#o1b');
PibPlay('co2c#d#eo1ba#bo2eo1bo2f#o1bo2g#ed#eg#eaf#b');
PibPlay('o3g#f#ed#f#ec#o2bo3c#o2bo3c#d#ef#g#o2ababo3c#');
PibPlay('d#ef#o2g#ag#abo3c#d#eo2f#o3c#o2co3c#d#c#o2af#mne');
PibPlay('o3mlef#g#abo4c#d#mne8mseee8e8g#4.');
PibPlay('msf8mse8d#8e8c#8o3bo4c#o3bo4c#o3bo4c#d#eo3a');
PibPlay('bababo4c#d#o3g#ag#ag#abo4c#o3f#g#f#g#f#');
PibPlay('g#f#g#f#g#f#d#o2bo3mlbo4c#d#mne8eee8e8g#4.');
PibPlay('msf#8e8d#8e8c#8o3bo4c#o3bo4c#o3b');
PibPlay('o4c#d#eo3abababo4c#d#o3g#ag#ag#abo4c#o3f#');
PibPlay('g#f#g#f#ag#f#e8o2b8o3e8g#g#g#8mng#g#g#8');
PibPlay('g#g#g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8f#8e8');
PibPlay('d#8c#8g#g#g#8g#g#g#8g#g#g#8o4c#8o3g#8');
PibPlay('o4c#8o3g#8o4c#8o3b8a#8b8a#8b8g#g#g#8');
PibPlay('g#g#g#8g#g#g#8o4c#8o3g#8o4c#8o3g#8o4c#8o3g#8');
PibPlay('f#8e8d#8c#8g#g#g#8g#g#g#8g#g#g#8');
PibPlay('o4c#8o3g#8o4c#8o3g#8o4c#8o3b8a#8b8a#8b8');
PibPlay('o2f#f#f#8f#f#f#8g#8a8f#4a8g#8');
PibPlay('e4g#8f#8o0b8o1b8o2f#f#f#8f#f#f#8');
PibPlay('g#8a8f#4a8g#8e4g#8f#8');
PibPlay('bbb8o1bbb8bbb8bbo2e8f#8g#8');
PibPlay('o1bbb8bbo2e8g#g#f#8d#8o1b8bbb8');
PibPlay('bbb8bbo2e8f#8g#8eg#mlb4mnb');
PibPlay('ag#f#e8o1b8o2e8o3bbb8bbb8bbo4e8');
PibPlay('f#8g#8o3bbb8bbo4e8g#g#f#8d#8o3b8');
PibPlay('bbb8bbb8bbo4e8f#8g#8o3eg#mlb4');
PibPlay('mnbag#f#mlef#g#mnamlg#abo4mnc#mlo3bo4c#d#mnemld#');
PibPlay('ef#mng#ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bmle');
PibPlay('f#g#mnamlg#abmno4c#mlo3bo4c#d#mnemld#ef#mng#ao3bo4ao3bo4a');
PibPlay('o3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bp16mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16');
PibPlay('mleo4eo3mnep16mlao4ao3mnap16mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16mleo4eo3mnep16');
PibPlay('mlao4ao3mnao4go3go4go3go4go3go4go3go4msg8e8c8e8o4mng#');
PibPlay('o3g#o4g#o3g#o4g#o3g#o4g#o3g#o4msg#8e8o3b8o4e8mng#o3g#o4g#o3g#o4g#');
PibPlay('o3g#o4g#o3g#o4msg#8f8c#8f8mna#o3a#o4a#o3a#o4a#o3a#o4a#o3a#o4msa#8');
PibPlay('g8e8g8b8p16mna#p16ap16g#p16f#p16ep16');
PibPlay('d#p16c#p16o3bp16a#p16ap16g#p16f#p16ep16d#p16f#mle');
PibPlay('f#g#mnamlg#abmno4c#o3mlbo4c#d#mnemld#ef#mng#ao3bo4ao3bo4a');
PibPlay('o3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bmlef#g#mnamlg#abmno4c#o3mlb');
PibPlay('o4c#d#mnemld#ef#mng#ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4ao3bo4a');
PibPlay('o3bo4ao3bp16mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16mleo4eo3mnep16mlao4ao3mnap16');
PibPlay('mlg#o4g#o3mng#p16mld#o4d#o3mnd#p16mleo4eo3mnep16mlao4ao3mnao4go3go4go3go4g');
PibPlay('o3go4go3go4g8e8c8e8g#o3g#o4g#o3g#o4g#o3g#o4g#o3g#o4g#8');
PibPlay('e8o3b8o4e8g#o3g#o4g#o3g#o4g#o3g#o4g#o3g#o4msg#8mnf8c#8');
PibPlay('f8a#o3a#o4a#o3a#o4a#o3a#o4a#o3a#o4a#8g8e8g8b8');
PibPlay('p16a#p16ap16g#p16f#p16ep16d#p16c#p16o3bp16a#p16');
PibPlay('ap16g#p16f#p16ep16d#p16fmled#ed#mne8bbb8');
PibPlay('bbb8bbo4e8f#8g#8o3bbb8bbb8');
PibPlay('bbo4g#8a8b8p8e8f#8g#8p8o3g#8');
PibPlay('a8b8p8p2o2bco3c#dd#');
PibPlay('eff#gg#aa#bco4c#d#ed#f#d#ed#f#d#e');
PibPlay('d#f#d#ed#f#d#ed#f#d#ed#f#d#ed#f#d#e');
PibPlay('d#f#d#e8eo3eo4eo3eo4eo3eo4e8o3bo2bo3bo2bo3bo2bo3b8');
PibPlay('g#o2g#o3g#o2g#o3g#o2g#o3g8eo2eo3eo2eo3eo2eo3e8eee8');
PibPlay('e8e8o2bbb8b8b8g#g#g#8g#8g#8');
PibPlay('eee8e8e8o1b8o2e8o1b8o2g#8e8b8');
PibPlay('g#8o3e8o2b8o3e8o2b8o3g#8e8b8g#8o4e4');
PibPlay('p8eee8e8e8e8e4p8.');
PibPlay('ee4p8.o2ee2');
End (* PibMusic *).